home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / sources.lha / sources / comp / back_end / vaxarithgen.t < prev    next >
Encoding:
Text File  |  1988-02-05  |  18.1 KB  |  427 lines

  1. (herald (back_end vaxarithgen)
  2.   (env t (orbit_top defs)))
  3.  
  4. ;;; Copyright (c) 1985 Yale University
  5. ;;;     Authors: N Adams, R Kelsey, D Kranz, J Philbin, J Rees.
  6. ;;; This material was developed by the T Project at the Yale University Computer 
  7. ;;; Science Department.  Permission to copy this software, to redistribute it, 
  8. ;;; and to use it for any purpose is granted, subject to the following restric-
  9. ;;; tions and understandings.
  10. ;;; 1. Any copy made of this software must include this copyright notice in full.
  11. ;;; 2. Users of this software agree to make their best efforts (a) to return
  12. ;;;    to the T Project at Yale any improvements or extensions that they make,
  13. ;;;    so that these may be included in future releases; and (b) to inform
  14. ;;;    the T Project of noteworthy uses of this software.
  15. ;;; 3. All materials developed as a consequence of the use of this software
  16. ;;;    shall duly acknowledge such use, in accordance with the usual standards
  17. ;;;    of acknowledging credit in academic research.
  18. ;;; 4. Yale has made no warrantee or representation that the operation of
  19. ;;;    this software will be error-free, and Yale is under no obligation to
  20. ;;;    provide any services, by way of maintenance, update, or otherwise.
  21. ;;; 5. In conjunction with products arising from the use of this material,
  22. ;;;    there shall be no use of the name of the Yale University nor of any
  23. ;;;    adaptation thereof in any advertising, promotional, or sales literature
  24. ;;;    without prior written consent from Yale in each case.
  25. ;;;
  26.  
  27. (define (vax-2op op size)
  28.   (xcase op                
  29.     ((mov) (select size
  30.              ((size/byte) vax/movb)
  31.              ((size/word) vax/movw)
  32.              ((size/long) vax/movl)
  33.              ((size/double) vax/movd)))
  34.     ((add) (select size
  35.              ((size/byte) vax/addb2)
  36.              ((size/word) vax/addw2)
  37.              ((size/long) vax/addl2)
  38.              ((size/double) vax/addd2)))
  39.     ((sub) (select size
  40.              ((size/byte) vax/subb2)
  41.              ((size/word) vax/subw2)
  42.              ((size/long) vax/subl2)
  43.              ((size/double) vax/subd2)))
  44.     ((div) (select size
  45.              ((size/byte) vax/divb2)
  46.              ((size/word) vax/divw2)
  47.              ((size/long) vax/divl2)
  48.              ((size/double) vax/divd2)))
  49.     ((andc) (select size
  50.               ((size/byte) vax/bicb2)
  51.               ((size/word) vax/bicw2)
  52.               ((size/long) vax/bicl2)))
  53.     ((mul) (select size
  54.              ((size/byte) vax/mulb2)
  55.              ((size/word) vax/mulw2)
  56.              ((size/long) vax/mull2)
  57.              ((size/double) vax/muld2)))
  58.     ((cmp) (select size
  59.              ((size/byte) vax/cmpb)
  60.              ((size/word) vax/cmpw)
  61.              ((size/long) vax/cmpl)
  62.              ((size/double) vax/cmpd)))
  63.     ((or)  (select size
  64.              ((size/byte) vax/bisb2)
  65.              ((size/word) vax/bisw2)
  66.              ((size/long) vax/bisl2)))
  67.     ((xor) (select size
  68.              ((size/byte) vax/xorb2)
  69.              ((size/word) vax/xorw2)
  70.              ((size/long) vax/xorl2)))))
  71.                                    
  72.  
  73. (define (vax-3op op size)
  74.   (xcase op                
  75.     ((add) (select size
  76.              ((size/byte) vax/addb3)
  77.              ((size/word) vax/addw3)
  78.              ((size/long) vax/addl3)
  79.              ((size/double) vax/addd3)))
  80.     ((sub) (select size
  81.              ((size/byte) vax/subb3)
  82.              ((size/word) vax/subw3)
  83.              ((size/long) vax/subl3)
  84.              ((size/double) vax/subd3)))
  85.     ((div) (select size
  86.              ((size/byte) vax/divb3)
  87.              ((size/word) vax/divw3)
  88.              ((size/long) vax/divl3)
  89.              ((size/double) vax/divd3)))
  90.     ((andc) (select size
  91.               ((size/byte) vax/bicb3)
  92.               ((size/word) vax/bicw3)
  93.               ((size/long) vax/bicl3)))
  94.     ((mul) (select size
  95.              ((size/byte) vax/mulb3)
  96.              ((size/word) vax/mulw3)
  97.              ((size/long) vax/mull3)
  98.              ((size/double) vax/muld3)))
  99.     ((or)  (select size
  100.              ((size/byte) vax/bisb3)
  101.              ((size/word) vax/bisw3)
  102.              ((size/long) vax/bisl3)))
  103.     ((xor) (select size
  104.              ((size/byte) vax/xorb3)
  105.              ((size/word) vax/xorw3)
  106.              ((size/long) vax/xorl3)))))
  107.  
  108. (define (fixnum-comparator node inst)       
  109.   (comparator node inst))
  110.  
  111. (define (character-comparator node inst)
  112.   (comparator node inst))
  113.  
  114. (define (comparator node inst)
  115.   (destructure (((then else () ref1 ref2) (call-args node)))
  116.     (let* ((val1 (leaf-value ref1))
  117.            (val2 (leaf-value ref2))
  118.            (rep (cond ((and (variable? val1) 
  119.                             (neq? (variable-rep val1) 'rep/pointer))
  120.                        (variable-rep val1))
  121.                       ((variable? val2) (variable-rep val2))
  122.                       (t 'rep/pointer))))
  123.         (let ((access (access-with-rep node val2 rep)))
  124.           (protect-access access)
  125.           (emit (vax-2op 'cmp (rep-size rep))
  126.                 (access-with-rep node val1 rep) 
  127.                 access)
  128.           (emit-jump (get-jop inst rep) else then)
  129.           (release-access access)))))
  130.                                         
  131. (define (get-jop inst rep)
  132.   (xcase inst 
  133.     ((jneq) jump-op/jn=)
  134.     ((jgeq)
  135.      (case rep
  136.        ((rep/char rep/integer-8-u rep/integer-16-u)  ;;; unsigned guys
  137.         jump-op/uj>=)
  138.        (else
  139.         jump-op/j>=)))))
  140.             
  141.  
  142.  
  143. (define (generate-char->ascii node)
  144.   (destructure (((cont arg) (call-args node)))
  145.     (receive (t-spec t-rep) (continuation-wants cont)
  146.       (let ((var (leaf-value arg))
  147.             (t-reg (get-target-register node t-spec))) 
  148.         (lock t-reg)            
  149.         (cond ((variable? var)
  150.                (let ((acc (access-value node var)))
  151.                  (unlock t-reg)
  152.                  (kill-if-dying var node)
  153.                  (case (variable-rep var)
  154.                    ((rep/char)
  155.                     (case t-rep 
  156.                       ((rep/pointer)
  157.                        (let ((s (get-register 'scratch node '*)))
  158.                          (emit vax/movzbl acc s)
  159.                          (emit vax/ashl (machine-num 2) s t-reg)))
  160.                       (else
  161.                        (emit vax/movzbl acc t-reg))))
  162.                    (else
  163.                     (case t-rep
  164.                       ((rep/pointer)
  165.                        (emit vax/ashl (machine-num -6) acc t-reg))
  166.                       (else
  167.                        (emit vax/ashl (machine-num -8) acc t-reg)))))))
  168.               (else
  169.                (emit vax/movl 
  170.                      (access-with-rep node (char->ascii var) t-rep) 
  171.                      t-reg)))
  172.           (mark-continuation node t-reg)))))
  173.  
  174. (define (generate-ascii->char node)
  175.   (destructure (((cont arg) (call-args node)))
  176.     (receive (t-spec t-rep) (continuation-wants cont)
  177.       (let ((var (leaf-value arg))
  178.             (t-reg (get-target-register node t-spec)))
  179.         (lock t-reg)                        
  180.         (cond ((variable? var)
  181.                (let ((acc (access-value node var)))
  182.                  (unlock t-reg)
  183.                  (kill-if-dying var node)
  184.                  (case (variable-rep var)
  185.                    ((rep/pointer)
  186.                     (case t-rep 
  187.                       ((rep/pointer)
  188.                        (emit vax/ashl (machine-num 6) acc t-reg)
  189.                        (emit vax/bicl3 (machine-num #xffff0000) t-reg t-reg)
  190.                        (emit vax/movb (machine-num header/char) t-reg))
  191.                       (else
  192.                        (emit vax/ashl (machine-num -2) acc t-reg))))
  193.                    (else
  194.                     (case t-rep
  195.                       ((rep/pointer)
  196.                        (emit vax/ashl (machine-num 8) acc t-reg)
  197.                        (emit vax/bicl3 (machine-num #xffff0000) t-reg t-reg)
  198.                        (emit vax/movb (machine-num header/char) t-reg))
  199.                       (else
  200.                        (if (neq? acc t-reg)
  201.                            (emit (vax-2op 'mov (rep-size (variable-rep var)))
  202.                  acc t-reg))))))))
  203.               (else
  204.                (emit vax/movl
  205.                      (access-with-rep node (ascii->char var) t-rep)
  206.                      t-reg)))
  207.           (mark-continuation node t-reg)))))
  208.  
  209.  
  210. (define (generate-fixnum-binop node inst commutes? strange?)
  211.  (case inst 
  212.    ((ash) (do-ash node))
  213.    ((mul) (do-multiply node))
  214.    ((div) (do-divide node))
  215.    (else
  216.   (destructure (((cont right left) (call-args node)))
  217.     (receive (t-spec t-rep) (continuation-wants cont)
  218.       (let* ((lvar (leaf-value left))
  219.              (rvar (leaf-value right))
  220.              (l-acc (access-with-rep node lvar t-rep)))
  221.         (protect-access l-acc)
  222.         (let ((r-acc (access-with-rep node rvar t-rep)))
  223.           (release-access l-acc)
  224.           (cond ((and (register? l-acc) (dying? lvar node) commutes?)
  225.                  (emit (vax-2op inst (rep-size t-rep)) r-acc l-acc)
  226.                  (kill lvar)
  227.                  (mark-continuation node l-acc))
  228.                 ((and (register? r-acc) (dying? rvar node))
  229.                  (emit (vax-2op inst (rep-size t-rep)) l-acc r-acc)
  230.                  (kill rvar)
  231.                  (mark-continuation node r-acc))
  232.                 (else
  233.                  (let ((t-reg (cond ((not (register? t-spec))
  234.                                      (get-register t-spec node '*))
  235.                                     ((and (not (locked? t-spec))
  236.                                           (maybe-free t-spec cont))
  237.                                      t-spec)
  238.                                     (else
  239.                                      (get-register (reg-type t-spec) node '*)))))
  240.                    (emit (vax-3op inst (rep-size t-rep)) l-acc r-acc t-reg)                                                                       
  241.                    (mark-continuation node t-reg)))))))))))
  242.  
  243.  
  244. (define (do-multiply node)           
  245.   (destructure (((cont right left) (call-args node)))
  246.     (receive (t-spec t-rep) (continuation-wants cont)
  247.       (let ((lvar (leaf-value left))
  248.             (rvar (leaf-value right)))
  249.         (receive (l-rep r-rep)
  250.                  (if (eq? t-rep 'rep/pointer)
  251.                      (cond ((variable? lvar) 
  252.                             (if (eq? (variable-rep lvar) 'rep/pointer)
  253.                                 (return 'rep/pointer 'rep/integer)
  254.                                 (return 'rep/integer 'rep/pointer)))
  255.                            ((and (variable? rvar)
  256.                                  (eq? (variable-rep rvar) 'rep/pointer))
  257.                             (return 'rep/integer 'rep/pointer))
  258.                            (else
  259.                             (return 'rep/pointer 'rep/integer)))
  260.                      (return t-rep t-rep))
  261.           (let ((l-acc (access-with-rep node lvar l-rep)))
  262.             (protect-access l-acc)
  263.             (let ((r-acc (access-with-rep node rvar r-rep)))
  264.               (release-access l-acc)
  265.               (cond ((and (register? l-acc) (dying? lvar node))
  266.                      (emit (vax-2op 'mul (rep-size t-rep)) r-acc l-acc)
  267.                      (kill lvar)
  268.                      (mark-continuation node l-acc))
  269.                     ((and (register? r-acc) (dying? rvar node))
  270.                      (emit (vax-2op 'mul (rep-size t-rep)) l-acc r-acc)
  271.                      (kill rvar)
  272.                      (mark-continuation node r-acc))
  273.                     (else
  274.                      (let ((t-reg (cond ((not (register? t-spec) )
  275.                                          (get-register t-spec node '*))
  276.                                         ((and (not (locked? t-spec))
  277.                                               (maybe-free t-spec cont))
  278.                                          t-spec)
  279.                                         (else
  280.                                          (get-register (reg-type t-spec) node '*)))))
  281.                        (emit (vax-3op 'mul (rep-size t-rep)) l-acc r-acc t-reg)                                                                       
  282.                        (mark-continuation node t-reg)))))))))))
  283.  
  284. (define (do-divide node)           
  285.   (destructure (((cont right left) (call-args node)))
  286.     (receive (t-spec t-rep) (continuation-wants cont)
  287.       (let ((lvar (leaf-value left))
  288.             (rvar (leaf-value right)))
  289.         (let ((l-acc (access-with-rep node lvar t-rep)))
  290.           (protect-access l-acc)
  291.           (let ((r-acc (access-with-rep node rvar t-rep)))
  292.             (release-access l-acc)
  293.             (cond ((eq? t-rep 'rep/pointer)
  294.                    (let* ((t-reg (cond ((not (register? t-spec) )
  295.                                         (get-register t-spec node '*))
  296.                                        ((and (not (locked? t-spec))
  297.                                              (maybe-free t-spec cont))
  298.                                         t-spec)
  299.                                        (else
  300.                                         (get-register (reg-type t-spec) node '*))))
  301.                           (scratch (if (eq? (reg-type t-reg) 'scratch)
  302.                                        t-reg
  303.                                        (get-register 'scratch node '*))))
  304.                      (emit vax/divl3 l-acc r-acc scratch)
  305.                      (emit vax/ashl (machine-num 2) scratch t-reg)
  306.                      (mark-continuation node t-reg)))
  307.                   ((and (register? r-acc) (dying? rvar node))
  308.                    (emit (vax-2op 'div (rep-size t-rep)) l-acc r-acc)
  309.                    (kill rvar)
  310.                    (mark-continuation node r-acc))
  311.                   (else
  312.                    (let ((t-reg (cond ((not (register? t-spec) )
  313.                                        (get-register t-spec node '*))
  314.                                       ((and (not (locked? t-spec))
  315.                                             (maybe-free t-spec cont))
  316.                                        t-spec)
  317.                                       (else
  318.                                        (get-register (reg-type t-spec) node '*)))))
  319.                      (emit (vax-3op 'div (rep-size t-rep)) l-acc r-acc t-reg)                                                                       
  320.                      (mark-continuation node t-reg))))))))))
  321.  
  322. (define (do-ash node)           
  323.   (destructure (((cont right left) (call-args node)))
  324.     (receive (t-spec t-rep) (continuation-wants cont)
  325.       (let ((lvar (leaf-value left))
  326.             (rvar (leaf-value right)))
  327.         (let ((l-acc (access-with-rep node lvar 'rep/integer)))
  328.           (protect-access l-acc)
  329.           (let ((r-acc (access-with-rep node rvar 'rep/integer)))
  330.             (release-access l-acc)
  331.             (cond ((rep-converter 'rep/integer t-rep)
  332.                    => (lambda (converter)
  333.                         (let* ((t-reg (cond ((not (register? t-spec) )
  334.                                              (get-register t-spec node '*)) 
  335.                                             ((and (not (locked? t-spec))
  336.                                                   (maybe-free t-spec cont))
  337.                                              t-spec)
  338.                                             (else
  339.                                              (get-register (reg-type t-spec)
  340.                                                             node '*))))
  341.                                (scratch (if (eq? (reg-type t-reg) 'scratch)
  342.                                             t-reg
  343.                                             (get-register 'scratch node '*))))
  344.                           (emit vax/ashl l-acc r-acc scratch)
  345.                           (converter node scratch t-reg)
  346.                           (mark-continuation node t-reg))))
  347.                   (else
  348.                    (let ((t-reg (cond ((not (register? t-spec) )
  349.                                        (get-register t-spec node '*))
  350.                                       ((and (not (locked? t-spec))
  351.                                             (maybe-free t-spec cont))
  352.                                        t-spec)
  353.                                       (else
  354.                                        (get-register (reg-type t-spec) node '*)))))
  355.                      (emit vax/ashl l-acc r-acc t-reg)       
  356.                      (mark-continuation node t-reg))))))))))
  357.  
  358.  
  359. (define (generate-two-fixnums node compare?)
  360.   (destructure (((then else () ref1 ref2) (call-args node)))
  361.     (let ((val1 (leaf-value ref1))
  362.           (reg2 (let ((reg (get-register 'scratch node '*)))
  363.                   (generate-move (access-with-rep node (leaf-value ref2)
  364.                           'rep/pointer) reg)
  365.                   reg)))
  366.       (lock reg2)
  367.       (let ((reg1 (let ((reg (get-register 'scratch node '*)))
  368.                                 (generate-move (access-with-rep node val1
  369.                                 'rep/pointer) reg)
  370.                                 reg)))
  371.     (lock reg1)
  372.     (let ((scratch (get-register 'scratch node '*)))
  373.     (unlock reg1)
  374.         (unlock reg2)                 
  375.         (generate-move reg1 SCRATCH)
  376.         (if (variable? (leaf-value ref2)) 
  377.             (emit vax/bisw2 reg2 SCRATCH))
  378.         (emit vax/bitl (machine-num 3) SCRATCH)
  379.         (emit-jump jump-op/jn= else then)      
  380.         (or compare?
  381.            (destructure (((arg1 arg2) (lambda-variables then)))
  382.              (mark arg1 reg1)
  383.              (mark arg2 reg2))))))))
  384.  
  385. (define (generate-op-with-overflow node op) 
  386.   (destructure (((then else () ref1 ref2) (call-args node)))
  387.     (let ((reg1 (register-loc (leaf-value ref1)))
  388.           (reg2 (register-loc (leaf-value ref2))))
  389.       (xcase op
  390.     ((add) (emit vax/addl2 reg2 reg1))
  391.     ((subtract) (emit vax/subl2 reg2 reg1))
  392.     ((multiply)
  393.      (emit vax/ashl ($ -2) reg1 reg1)
  394.      (emit vax/mull2 reg2 reg1)))
  395.       (emit-jump jump-op/overflow then else)                               
  396.       (kill (leaf-value ref1))
  397.       (kill (leaf-value ref2))
  398.       (mark (car (lambda-variables else)) reg1))))
  399.  
  400. (define (generate-hack-dr node op)
  401.   (destructure (((#f ref1 ref2) (call-args node)))
  402.     (let ((reg1 (register-loc (leaf-value ref1)))
  403.           (reg2 (register-loc (leaf-value ref2))))
  404.       (xcase op
  405.     ((divide)
  406.      (emit vax/divl2 reg2 reg1)
  407.      (emit vax/ashl ($ 2) reg1 reg1))
  408.     ((remainder)
  409.      (lock reg1)
  410.      (lock reg2)
  411.      (let ((temp (get-register 'scratch node '*)))
  412.        (unlock reg1)
  413.        (unlock reg2)
  414.        (emit vax/divl3 reg2 reg1 temp)
  415.        (emit vax/mull2 reg2 temp)
  416.        (emit vax/subl2 temp reg1))))
  417.       (kill (leaf-value ref1))
  418.       (kill (leaf-value ref2))
  419.       (mark-continuation node reg1))))
  420.  
  421.  
  422.  
  423.  
  424.  
  425.  
  426.  
  427.